﻿
Partial Class Goods_tbKey
    Inherits System.Web.UI.Page
    Public connstr, conn, connB, rs, rs1, rs2, Footer, RsStr, GoodsKeyTitle, GoodsKeyMoBan, GoodsKeyBottomKeyCount, GoodsKeyZmPageKeyCount, GoodsKeyShowItem
    Public Shared Function MD5(ByVal strSource As String, ByVal Code As Int16) As String
        '这里用的是ascii编码密码原文，如果要用汉字做密码，可以用UnicodeEncoding，但会与ASP中的MD5函数不兼容 
        Dim dataToHash As Byte() = (New System.Text.ASCIIEncoding).GetBytes(strSource)
        Dim hashvalue As Byte() = CType(System.Security.Cryptography.CryptoConfig.CreateFromName("MD5"), System.Security.Cryptography.HashAlgorithm).ComputeHash(dataToHash)
        Dim i As Integer
        Select Case Code
            Case 16 '′选择16位字符的加密结果 
                For i = 4 To 11
                    MD5 += Hex(hashvalue(i)).ToLower
                Next
            Case 32 ' ′选择32位字符的加密结果 
                For i = 0 To 15
                    MD5 += Hex(hashvalue(i)).ToLower
                Next
            Case Else ' ′Code错误时，返回全部字符串，即32位字符 
                For i = 0 To hashvalue.Length - 1
                    MD5 += Hex(hashvalue(i)).ToLower
                Next
        End Select
    End Function
    Function EncodeBase64(ByVal StrA)
        Dim BufferA As Byte()
        BufferA = System.Text.Encoding.Default.GetBytes(StrA)
        Dim StrB As String
        StrB = Convert.ToBase64String(BufferA)
        EncodeBase64 = StrB
    End Function
    Function DecodeBase64(ByVal StrA)
        DecodeBase64 = Encoding.GetEncoding("gb2312").GetString(Convert.FromBase64String(StrA))
    End Function

    Function getstr(ByVal iRemote)
        On Error Resume Next
        Dim xPost, sGet
        iRemote = iRemote
        xPost = Server.CreateObject("msxml2.serverxmlhttp") 'msxml2.serverxmlhttp
        xPost.Open("GET", iRemote, False)
        xPost.setrequestheader("referer", "http://taoke.alimama.com/spreader/search_auction.htm")
        xPost.Send()
        sGet = CreateObject("ADODB.Stream")
        sGet.Mode = 3
        sGet.Type = 1
        sGet.Open()
        On Error Resume Next

        sGet.Write(xPost.responseBody)
        sGet.Position = 0
        sGet.Type = 2
        If InStr(iRemote, "suggest.taobao.com") Then
            sGet.Charset = "utf-8" ' "gb2312"
        Else
            sGet.Charset = "gb2312" ' "gb2312"
        End If

        getstr = sGet.ReadText
    End Function

    Function getText(ByVal tmp, ByVal s, ByVal e, ByVal id)
        'On Error Resume Next
        Dim String1, String2, arrstr
        String1 = s
        String2 = e
        Dim fbegin
        Dim fend
        fbegin = 1
        fend = 1
        Do
            fbegin = InStr(fbegin, tmp, String1)
            If fbegin = 0 Then Exit Function
            fend = InStr(fbegin, tmp, String2)
            arrstr = Mid(tmp, fbegin + Len(String1), fend - (fbegin + Len(String1)))
            If id = 1 Then getText = arrstr : Exit Function
            getText = getText & arrstr & "[,]"
            fbegin = fend + Len(String2)
        Loop While True
    End Function

    Protected Sub Page_Load(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Load
        If Request.Cookies("TaoddAdmin") Is Nothing Or Request.Cookies("TaoddPassWord") Is Nothing Then
            Response.Redirect("login.aspx")
        End If
        'Response.Write(ConfigurationSettings.AppSettings("SQLConnString") & """" & Server.MapPath(".") & "\..\" & Left(ConfigurationSettings.AppSettings("dbPath"), InStr(ConfigurationSettings.AppSettings("dbPath"), "/") - 1) & "\keyword.mdb")
        'Response.End()
        connstr = ConfigurationSettings.AppSettings("SQLConnString") & """" & Server.MapPath(".") & "\..\" & ConfigurationSettings.AppSettings("dbPath") & """"
        conn = Server.CreateObject("ADODB.Connection")
        conn.open(connstr)
        connB = Server.CreateObject("ADODB.Connection")
        connB.open(ConfigurationSettings.AppSettings("SQLConnString") & """" & Server.MapPath(".") & "\..\" & Left(ConfigurationSettings.AppSettings("dbPath"), InStr(ConfigurationSettings.AppSettings("dbPath"), "/")) & "keyword.mdb""")

        RsStr = Server.CreateObject("Adodb.Connection")
        RsStr.open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Server.MapPath("Article_Manager/pinyin.mdb"))
        rs = Server.CreateObject("adodb.recordset")
        rs1 = Server.CreateObject("adodb.recordset")
        rs2 = Server.CreateObject("adodb.recordset")
        If Request.QueryString("Action") = "tbkey" Then
            tbkey()
            'Response.Write(GetXgKey("士"))
            Response.End()
        End If
        If Request("action") = "EditGoodsKeyTitle" Then

            rs1.open("select *  from Config", conn, 1, 3)
            If Not rs1.eof Then
                rs1("GoodsKeyTitle").value = Request.Form("GoodsKeyTitle")
                rs1("GoodsKeyShowItem").value = Request("ShowItem")
                rs1("GoodsKeyBottomKeyCount").value = Request("GoodsKeyBottomKeyCount")
                rs1("GoodsKeyZmPageKeyCount").value = Request("GoodsKeyZmPageKeyCount")
                rs1.update()
            End If
            rs1.close()
            Response.Write("<script language=javascript>alert('修改成功！');window.location.href='Goods_tbKey.aspx?action=ShowSet'</script>")
            Response.End()
        End If
        If Request("action") = "EditGoodsKeyMoBan" Then
            rs1.open("select *  from Config", conn, 1, 3)
            If Not rs1.eof Then
                rs1("GoodsKeyMoBan").value = Request.Form("content")
                rs1.update()
            End If
            rs1.close()
            Response.Write("<script language=javascript>alert('修改成功！');window.location.href='Goods_tbKey.aspx?action=Moban'</script>")
            Response.End()
        End If
        rs1.open("select *  from Config", conn, 1, 3)
        If Not rs1.eof Then
            GoodsKeyTitle = rs1("GoodsKeyTitle").value
            GoodsKeyMoBan = rs1("GoodsKeyMoBan").value
            GoodsKeyBottomKeyCount = rs1("GoodsKeyBottomKeyCount").value
            GoodsKeyZmPageKeyCount = rs1("GoodsKeyZmPageKeyCount").value
            If Not IsDBNull(rs1("GoodsKeyShowItem").value) Then GoodsKeyShowItem = rs1("GoodsKeyShowItem").value
        End If
        rs1.close()

    End Sub

    Function tbkey()
        On Error Resume Next
        Dim HanZi, CurHanZi, SugKeyArrStr, i, AddResult, NowStr
        Randomize()
        NowStr = Trim(Now)
        NowStr = Right(NowStr, Len(NowStr) - InStrRev(NowStr, " "))
        rs.open("select top 1 *  from Key_List where do=false order by rnd(-(id+" & Rnd() & "))", connB, 1, 3)
        If Not rs.eof Then
            SugKeyArrStr = GetSugKey(rs("key").value)
            If InStr(SugKeyArrStr, "[,]") Then
                AddResult = AddKeyToDb(SugKeyArrStr)
            End If
            SugKeyArrStr = GetXgKey(rs("key").value)
            If InStr(SugKeyArrStr, "[,]") Then
                AddResult = AddResult + AddKeyToDb(SugKeyArrStr)
            End If

            If Not IsNumeric(AddResult) Then AddResult = 0
            Response.Write("Add|" & AddResult & "|" & NowStr)
            'rs("do") = True
            ' AddResult = 0
            'Response.Write(AddResult & "个")
            'rs.update()
            connB.execute("update Key_List set do=true where key='" & Replace(rs("key").value, "'", "''") & "'")
        Else
            rs2.open("select *  from PinYin", RsStr, 1, 3)
            HanZi = ""
            While Not rs2.eof
                HanZi = HanZi & rs2("content").value
                rs2.movenext()
            End While
            CurHanZi = Mid(HanZi, Rnd() * (Len(HanZi) - 1), 1)
            AddResult = AddKeyToDb(CurHanZi & "[,]")
            Response.Write("Add|" & AddResult & "|" & NowStr)
            rs2.close()
        End If
        rs.close()
        connB.close()
        Response.End()

    End Function

    Function AddKeyToDb(ByVal key)
        Dim SugKeyArr, i, p
        SugKeyArr = Split(key, "[,]")
        p = 0
        
        For i = 0 To UBound(SugKeyArr)
            If SugKeyArr(i) <> "" Then
                'Response.Write(SugKeyArr(i))
                'Response.End()
                rs1.open("select *  from Key_List where key='" & Replace(SugKeyArr(i), "'", "''") & "'", connB, 1, 3)
                If rs1.eof Then
                    p = p + 1
                    rs1.addnew()
                    rs1("key").value = SugKeyArr(i)
                    rs1("zm").value = PinYin(SugKeyArr(i))
                    rs1.update()
                End If
                rs1.close()
            End If
        Next
        AddKeyToDb = p
    End Function
    Function GetSugKey(ByVal key)
        Dim url, code
        url = "http://suggest.taobao.com/sug?q=" & GBtoUTF8(key) & "&code=utf-8&callback=KISSY.Suggest.callback"
        code = getstr(url)
        If InStr(code, """result"": []}") Then
            GetSugKey = "null"
            Exit Function
        Else
            GetSugKey = getText(code, "[""", """,", 2)
        End If
    End Function

    Function GetXgKey(ByVal key)
        Dim url, code
        'url = "http://suggest.taobao.com/sug?q=" & GBtoUTF8(key) & "&code=utf-8&callback=KISSY.Suggest.callback"
        url = "http://s.taobao.com/search?q=" & Server.UrlEncode(key) & "&commend=all&ssid=s5-e&search_type=item&atype=&filterFineness="
        code = getstr(url)
        If InStr(code, "<dl class=""related-search"">") = 0 Then
            GetXgKey = "null"
            Exit Function
        Else
            code = getText(code, "<dl class=""related-search"">", "</dl>", 1)
            GetXgKey = getText(code, """>", "</a>", 2)
        End If
    End Function

    Function delHtml(ByVal strHtml) '删除HTML格式
        Dim re
        re = New Regex("<.+?>", RegexOptions.IgnoreCase)
        delHtml = re.Replace(strHtml, "")
        re = Nothing
    End Function
    Function GBtoUTF8(ByVal szInput) 'URL编码(utf-8)
        Dim wch, uch, szRet
        Dim x
        Dim nAsc

        '如果输入参数为空，则退出函数
        If szInput = "" Then
            GBtoUTF8 = szInput
            Exit Function
        End If

        '开始转换
        For x = 1 To Len(szInput)
            wch = Mid(szInput, x, 1)
            nAsc = AscW(wch)

            If nAsc < 0 Then nAsc = nAsc + 65536

            If (nAsc And &HFF80) = 0 Then
                szRet = szRet & wch
            Else
                If (nAsc And &HF000) = 0 Then
                    uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                    szRet = szRet & uch
                Else
                    uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                    Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                    Hex(nAsc And &H3F Or &H80)
                    szRet = szRet & uch
                End If
            End If
        Next
        GBtoUTF8 = Replace(szRet, "&", "%26")
    End Function

    Public Function PinYin(ByVal StrChar)
        Dim StrLens, StrLen, StrTitle, IFCN, i, PinYinRs
        On Error Resume Next
        IFCN = True
        'For i = 1 To Len(StrChar)
        StrTitle = IFCN
        'StrLen = Mid(StrChar, i, 1)
        StrLen = Left(StrChar, 1)
        If Len(Trim(StrLen)) = 1 Then
            PinYinRs = RsStr.execute("select top 1 pinyin from pinyin where content like '%" & StrLen & "%'")
            If Err.Number <> 0 Then
                ' Response.Write("select top 1 pinyin from pinyin where content like '%" & StrLen & "%'")
                'Response.End()
            End If
            If Not PinYinRs.eof And Not PinYinRs.bof Then
                StrLen = PinYinRs(0).value
                IFCN = True
            Else
                IFCN = False
            End If
            PinYinRs.Close()
        Else
            StrLen = " "
        End If
        If StrTitle = IFCN Then
            StrLens = StrLens & StrLen
        Else
            StrLens = StrLens & " " & StrLen
        End If
        'Next
        PinYin = LCase(Trim(StrLens))
        If Len(PinYin) > 1 Then PinYin = Left(PinYin, 1)
    End Function
    Protected Sub Page_Unload(ByVal sender As Object, ByVal e As System.EventArgs) Handles Me.Unload
        On Error Resume Next
        conn.close()
        RsStr.close()
        connB.close()

    End Sub
End Class

